home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / ExtUtils / Constant / ProxySubs.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  14.6 KB  |  525 lines
  1. package ExtUtils::Constant::ProxySubs;
  2.  
  3. use strict;
  4. use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv
  5.         %type_to_C_value %type_is_a_problem %type_num_args
  6.         %type_temporary);
  7. use Carp;
  8. require ExtUtils::Constant::XS;
  9. use ExtUtils::Constant::Utils qw(C_stringify);
  10. use ExtUtils::Constant::XS qw(%XS_TypeSet);
  11.  
  12. $VERSION = '0.05';
  13. @ISA = 'ExtUtils::Constant::XS';
  14.  
  15. %type_to_struct =
  16.     (
  17.      IV => '{const char *name; I32 namelen; IV value;}',
  18.      NV => '{const char *name; I32 namelen; NV value;}',
  19.      UV => '{const char *name; I32 namelen; UV value;}',
  20.      PV => '{const char *name; I32 namelen; const char *value;}',
  21.      PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}',
  22.      YES => '{const char *name; I32 namelen;}',
  23.      NO => '{const char *name; I32 namelen;}',
  24.      UNDEF => '{const char *name; I32 namelen;}',
  25.      '' => '{const char *name; I32 namelen;} ',
  26.      );
  27.  
  28. %type_from_struct =
  29.     (
  30.      IV => sub { $_[0] . '->value' },
  31.      NV => sub { $_[0] . '->value' },
  32.      UV => sub { $_[0] . '->value' },
  33.      PV => sub { $_[0] . '->value' },
  34.      PVN => sub { $_[0] . '->value', $_[0] . '->len' },
  35.      YES => sub {},
  36.      NO => sub {},
  37.      UNDEF => sub {},
  38.      '' => sub {},
  39.     );
  40.  
  41. %type_to_sv = 
  42.     (
  43.      IV => sub { "newSViv($_[0])" },
  44.      NV => sub { "newSVnv($_[0])" },
  45.      UV => sub { "newSVuv($_[0])" },
  46.      PV => sub { "newSVpv($_[0], 0)" },
  47.      PVN => sub { "newSVpvn($_[0], $_[1])" },
  48.      YES => sub { '&PL_sv_yes' },
  49.      NO => sub { '&PL_sv_no' },
  50.      UNDEF => sub { '&PL_sv_undef' },
  51.      '' => sub { '&PL_sv_yes' },
  52.      SV => sub {"SvREFCNT_inc($_[0])"},
  53.      );
  54.  
  55. %type_to_C_value = 
  56.     (
  57.      YES => sub {},
  58.      NO => sub {},
  59.      UNDEF => sub {},
  60.      '' => sub {},
  61.      );
  62.  
  63. sub type_to_C_value {
  64.     my ($self, $type) = @_;
  65.     return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
  66. }
  67.  
  68. # TODO - figure out if there is a clean way for the type_to_sv code to
  69. # attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add
  70. # SvREFCNT_inc
  71. %type_is_a_problem =
  72.     (
  73.      # The documentation says *mortal SV*, but we now need a non-mortal copy.
  74.      SV => 1,
  75.      );
  76.  
  77. %type_temporary =
  78.     (
  79.      SV => ['SV *'],
  80.      PV => ['const char *'],
  81.      PVN => ['const char *', 'STRLEN'],
  82.      );
  83. $type_temporary{$_} = [$_] foreach qw(IV UV NV);
  84.      
  85. while (my ($type, $value) = each %XS_TypeSet) {
  86.     $type_num_args{$type}
  87.     = defined $value ? ref $value ? scalar @$value : 1 : 0;
  88. }
  89. $type_num_args{''} = 0;
  90.  
  91. sub partition_names {
  92.     my ($self, $default_type, @items) = @_;
  93.     my (%found, @notfound, @trouble);
  94.  
  95.     while (my $item = shift @items) {
  96.     my $default = delete $item->{default};
  97.     if ($default) {
  98.         # If we find a default value, convert it into a regular item and
  99.         # append it to the queue of items to process
  100.         my $default_item = {%$item};
  101.         $default_item->{invert_macro} = 1;
  102.         $default_item->{pre} = delete $item->{def_pre};
  103.         $default_item->{post} = delete $item->{def_post};
  104.         $default_item->{type} = shift @$default;
  105.         $default_item->{value} = $default;
  106.         push @items, $default_item;
  107.     } else {
  108.         # It can be "not found" unless it's the default (invert the macro)
  109.         # or the "macro" is an empty string (ie no macro)
  110.         push @notfound, $item unless $item->{invert_macro}
  111.         or !$self->macro_to_ifdef($self->macro_from_item($item));
  112.     }
  113.  
  114.     if ($item->{pre} or $item->{post} or $item->{not_constant}
  115.         or $type_is_a_problem{$item->{type}}) {
  116.         push @trouble, $item;
  117.     } else {
  118.         push @{$found{$item->{type}}}, $item;
  119.     }
  120.     }
  121.     # use Data::Dumper; print Dumper \%found;
  122.     (\%found, \@notfound, \@trouble);
  123. }
  124.  
  125. sub boottime_iterator {
  126.     my ($self, $type, $iterator, $hash, $subname) = @_;
  127.     my $extractor = $type_from_struct{$type};
  128.     die "Can't find extractor code for type $type"
  129.     unless defined $extractor;
  130.     my $generator = $type_to_sv{$type};
  131.     die "Can't find generator code for type $type"
  132.     unless defined $generator;
  133.  
  134.     my $athx = $self->C_constant_prefix_param();
  135.  
  136.     return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
  137.         while ($iterator->name) {
  138.         $subname($athx $hash, $iterator->name,
  139.                 $iterator->namelen, %s);
  140.         ++$iterator;
  141.     }
  142. EOBOOT
  143. }
  144.  
  145. sub name_len_value_macro {
  146.     my ($self, $item) = @_;
  147.     my $name = $item->{name};
  148.     my $value = $item->{value};
  149.     $value = $item->{name} unless defined $value;
  150.  
  151.     my $namelen = length $name;
  152.     if ($name =~ tr/\0-\377// != $namelen) {
  153.     # the hash API signals UTF-8 by passing the length negated.
  154.     utf8::encode($name);
  155.     $namelen = -length $name;
  156.     }
  157.     $name = C_stringify($name);
  158.  
  159.     my $macro = $self->macro_from_item($item);
  160.     ($name, $namelen, $value, $macro);
  161. }
  162.  
  163. sub WriteConstants {
  164.     my $self = shift;
  165.     my $ARGS = {@_};
  166.  
  167.     my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package)
  168.     = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)};
  169.  
  170.     my $options = $ARGS->{PROXYSUBS};
  171.     $options = {} unless ref $options;
  172.     my $explosives = $options->{croak_on_read};
  173.  
  174.     $xs_subname ||= 'constant';
  175.  
  176.     # If anyone is insane enough to suggest a package name containing %
  177.     my $package_sprintf_safe = $package;
  178.     $package_sprintf_safe =~ s/%/%%/g;
  179.  
  180.     # All the types we see
  181.     my $what = {};
  182.     # A hash to lookup items with.
  183.     my $items = {};
  184.  
  185.     my @items = $self->normalise_items ({disable_utf8_duplication => 1},
  186.                     $default_type, $what, $items,
  187.                     @{$ARGS->{NAMES}});
  188.  
  189.     # Partition the values by type. Also include any defaults in here
  190.     # Everything that doesn't have a default needs alternative code for
  191.     # "I'm missing"
  192.     # And everything that has pre or post code ends up in a private block
  193.     my ($found, $notfound, $trouble)
  194.     = $self->partition_names($default_type, @items);
  195.  
  196.     my $pthx = $self->C_constant_prefix_param_defintion();
  197.     my $athx = $self->C_constant_prefix_param();
  198.     my $symbol_table = C_stringify($package) . '::';
  199.  
  200.     print $c_fh $self->header(), <<"EOADD";
  201. static void
  202. ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
  203.     SV **sv = hv_fetch(hash, name, namelen, TRUE);
  204.     if (!sv) {
  205.         Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
  206.            name);
  207.     }
  208.     if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) {
  209.     /* Someone has been here before us - have to make a real sub.  */
  210.     newCONSTSUB(hash, name, value);
  211.     } else {
  212.     SvUPGRADE(*sv, SVt_RV);
  213.     SvRV_set(*sv, value);
  214.     SvROK_on(*sv);
  215.     SvREADONLY_on(value);
  216.     }
  217. }
  218.  
  219. EOADD
  220.  
  221.     print $c_fh $explosives ? <<"EXPLODE" : "\n";
  222.  
  223. static int
  224. Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
  225. {
  226.     PERL_UNUSED_ARG(mg);
  227.     Perl_croak(aTHX_
  228.            "Your vendor has not defined $package_sprintf_safe macro %"SVf
  229.            " used", sv);
  230.     NORETURN_FUNCTION_END;
  231. }
  232.  
  233. static MGVTBL not_defined_vtbl = {
  234.  Im_sorry_Dave, /* get - I'm afraid I can't do that */
  235.  Im_sorry_Dave, /* set */
  236.  0, /* len */
  237.  0, /* clear */
  238.  0, /* free */
  239.  0, /* copy */
  240.  0, /* dup */
  241. };
  242.  
  243. EXPLODE
  244.  
  245. {
  246.     my $key = $symbol_table;
  247.     # Just seems tidier (and slightly more space efficient) not to have keys
  248.     # such as Fcntl::
  249.     $key =~ s/::$//;
  250.     my $key_len = length $key;
  251.  
  252.     print $c_fh <<"MISSING";
  253.  
  254. #ifndef SYMBIAN
  255.  
  256. /* Store a hash of all symbols missing from the package. To avoid trampling on
  257.    the package namespace (uninvited) put each package's hash in our namespace.
  258.    To avoid creating lots of typeblogs and symbol tables for sub-packages, put
  259.    each package's hash into one hash in our namespace.  */
  260.  
  261. static HV *
  262. get_missing_hash(pTHX) {
  263.     HV *const parent
  264.     = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI);
  265.     /* We could make a hash of hashes directly, but this would confuse anything
  266.     at Perl space that looks at us, and as we're visible in Perl space,
  267.     best to play nice. */
  268.     SV *const *const ref
  269.     = hv_fetch(parent, "$key", $key_len, TRUE);
  270.     HV *new_hv;
  271.  
  272.     if (!ref)
  273.     return NULL;
  274.  
  275.     if (SvROK(*ref))
  276.     return (HV*) SvRV(*ref);
  277.  
  278.     new_hv = newHV();
  279.     SvUPGRADE(*ref, SVt_RV);
  280.     SvRV_set(*ref, (SV *)new_hv);
  281.     SvROK_on(*ref);
  282.     return new_hv;
  283. }
  284.  
  285. #endif
  286.  
  287. MISSING
  288.  
  289. }
  290.  
  291.     print $xs_fh <<"EOBOOT";
  292. BOOT:
  293.   {
  294. #ifdef dTHX
  295.     dTHX;
  296. #endif
  297.     HV *symbol_table = get_hv("$symbol_table", TRUE);
  298. #ifndef SYMBIAN
  299.     HV *${c_subname}_missing;
  300. #endif
  301. EOBOOT
  302.  
  303.     my %iterator;
  304.  
  305.     $found->{''}
  306.         = [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
  307.  
  308.     foreach my $type (sort keys %$found) {
  309.     my $struct = $type_to_struct{$type};
  310.     my $type_to_value = $self->type_to_C_value($type);
  311.     my $number_of_args = $type_num_args{$type};
  312.     die "Can't find structure definition for type $type"
  313.         unless defined $struct;
  314.  
  315.     my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
  316.     print $c_fh "struct $struct_type $struct;\n";
  317.  
  318.     my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
  319.     print $xs_fh <<"EOBOOT";
  320.  
  321.     static const struct $struct_type $array_name\[] =
  322.       {
  323. EOBOOT
  324.  
  325.  
  326.     foreach my $item (@{$found->{$type}}) {
  327.             my ($name, $namelen, $value, $macro)
  328.                  = $self->name_len_value_macro($item);
  329.  
  330.         my $ifdef = $self->macro_to_ifdef($macro);
  331.         if (!$ifdef && $item->{invert_macro}) {
  332.         carp("Attempting to supply a default for '$name' which has no conditional macro");
  333.         next;
  334.         }
  335.         print $xs_fh $ifdef;
  336.         if ($item->{invert_macro}) {
  337.         print $xs_fh
  338.             "        /* This is the default value: */\n" if $type;
  339.         print $xs_fh "#else\n";
  340.         }
  341.         print $xs_fh "        { ", join (', ', "\"$name\"", $namelen,
  342.                          &$type_to_value($value)), " },\n",
  343.                          $self->macro_to_endif($macro);
  344.     }
  345.  
  346.  
  347.     # Terminate the list with a NULL
  348.     print $xs_fh "        { NULL, 0", (", 0" x $number_of_args), " } };\n";
  349.  
  350.     $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
  351.  
  352.     print $xs_fh <<"EOBOOT";
  353.     const struct $struct_type *$iterator{$type} = $array_name;
  354. EOBOOT
  355.     }
  356.  
  357.     delete $found->{''};
  358.  
  359.     print $xs_fh <<"EOBOOT";
  360. #ifndef SYMBIAN
  361.     ${c_subname}_missing = get_missing_hash(aTHX);
  362. #endif
  363. EOBOOT
  364.  
  365.     my $add_symbol_subname = $c_subname . '_add_symbol';
  366.     foreach my $type (sort keys %$found) {
  367.     print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 
  368.                           'symbol_table',
  369.                           $add_symbol_subname);
  370.     }
  371.  
  372.     print $xs_fh <<"EOBOOT";
  373.     while (value_for_notfound->name) {
  374. EOBOOT
  375.  
  376.     print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
  377.         SV *tripwire = newSV(0);
  378.         
  379.         sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0);
  380.         SvPV_set(tripwire, (char *)value_for_notfound->name);
  381.         if(value_for_notfound->namelen >= 0) {
  382.         SvCUR_set(tripwire, value_for_notfound->namelen);
  383.         } else {
  384.         SvCUR_set(tripwire, -value_for_notfound->namelen);
  385.         SvUTF8_on(tripwire);
  386.         }
  387.         SvPOKp_on(tripwire);
  388.         SvREADONLY_on(tripwire);
  389.         assert(SvLEN(tripwire) == 0);
  390.  
  391.         $add_symbol_subname($athx symbol_table, value_for_notfound->name,
  392.                 value_for_notfound->namelen, tripwire);
  393. EXPLODE
  394.  
  395.         /* Need to add prototypes, else parsing will vary by platform.  */
  396.         SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
  397.                    value_for_notfound->namelen, TRUE);
  398.         if (!sv) {
  399.         Perl_croak($athx
  400.                "Couldn't add key '%s' to %%$package_sprintf_safe\::",
  401.                value_for_notfound->name);
  402.         }
  403.         if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) {
  404.         /* Nothing was here before, so mark a prototype of ""  */
  405.         sv_setpvn(*sv, "", 0);
  406.         } else if (SvPOK(*sv) && SvCUR(*sv) == 0) {
  407.         /* There is already a prototype of "" - do nothing  */
  408.         } else {
  409.         /* Someone has been here before us - have to make a real
  410.            typeglob.  */
  411.         /* It turns out to be incredibly hard to deal with all the
  412.            corner cases of sub foo (); and reporting errors correctly,
  413.            so lets cheat a bit.  Start with a constant subroutine  */
  414.         CV *cv = newCONSTSUB(symbol_table, value_for_notfound->name,
  415.                      &PL_sv_yes);
  416.         /* and then turn it into a non constant declaration only.  */
  417.         SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
  418.         CvCONST_off(cv);
  419.         CvXSUB(cv) = NULL;
  420.         CvXSUBANY(cv).any_ptr = NULL;
  421.         }
  422. #ifndef SYMBIAN
  423.         if (!hv_store(${c_subname}_missing, value_for_notfound->name,
  424.               value_for_notfound->namelen, &PL_sv_yes, 0))
  425.         Perl_croak($athx "Couldn't add key '%s' to missing_hash",
  426.                value_for_notfound->name);
  427. #endif
  428. DONT
  429.  
  430.     print $xs_fh <<"EOBOOT";
  431.  
  432.         ++value_for_notfound;
  433.     }
  434. EOBOOT
  435.  
  436.     foreach my $item (@$trouble) {
  437.         my ($name, $namelen, $value, $macro)
  438.         = $self->name_len_value_macro($item);
  439.         my $ifdef = $self->macro_to_ifdef($macro);
  440.         my $type = $item->{type};
  441.     my $type_to_value = $self->type_to_C_value($type);
  442.  
  443.         print $xs_fh $ifdef;
  444.     if ($item->{invert_macro}) {
  445.         print $xs_fh
  446.          "        /* This is the default value: */\n" if $type;
  447.         print $xs_fh "#else\n";
  448.     }
  449.     my $generator = $type_to_sv{$type};
  450.     die "Can't find generator code for type $type"
  451.         unless defined $generator;
  452.  
  453.     print $xs_fh "        {\n";
  454.     # We need to use a temporary value because some really troublesome
  455.     # items use C pre processor directives in their values, and in turn
  456.     # these don't fit nicely in the macro-ised generator functions
  457.     my $counter = 0;
  458.     printf $xs_fh "            %s temp%d;\n", $_, $counter++
  459.         foreach @{$type_temporary{$type}};
  460.  
  461.     print $xs_fh "            $item->{pre}\n" if $item->{pre};
  462.  
  463.     # And because the code in pre might be both declarations and
  464.     # statements, we can't declare and assign to the temporaries in one.
  465.     $counter = 0;
  466.     printf $xs_fh "            temp%d = %s;\n", $counter++, $_
  467.         foreach &$type_to_value($value);
  468.  
  469.     my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
  470.     printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
  471.         ${c_subname}_add_symbol($athx symbol_table, "%s",
  472.                     $namelen, %s);
  473. EOBOOT
  474.     print $xs_fh "        $item->{post}\n" if $item->{post};
  475.     print $xs_fh "        }\n";
  476.  
  477.         print $xs_fh $self->macro_to_endif($macro);
  478.     }
  479.  
  480.     print $xs_fh <<EOBOOT;
  481.     /* As we've been creating subroutines, we better invalidate any cached
  482.        methods  */
  483.     ++PL_sub_generation;
  484.   }
  485. EOBOOT
  486.  
  487.     print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
  488.  
  489. void
  490. $xs_subname(sv)
  491.     INPUT:
  492.     SV *        sv;
  493.     PPCODE:
  494.     sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
  495.               ", used", sv);
  496.         PUSHs(sv_2mortal(sv));
  497. EXPLODE
  498.  
  499. void
  500. $xs_subname(sv)
  501.     PREINIT:
  502.     STRLEN        len;
  503.     INPUT:
  504.     SV *        sv;
  505.         const char *    s = SvPV(sv, len);
  506.     PPCODE:
  507. #ifdef SYMBIAN
  508.     sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv);
  509. #else
  510.     HV *${c_subname}_missing = get_missing_hash(aTHX);
  511.     if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) {
  512.         sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
  513.               ", used", sv);
  514.     } else {
  515.         sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
  516.               sv);
  517.     }
  518. #endif
  519.     PUSHs(sv_2mortal(sv));
  520. DONT
  521.  
  522. }
  523.  
  524. 1;
  525.